Dror Bar-Natan: Papers: WKO:

The "Infinitesimal Alexander Module"

Pensieve Header: Work on the “infinitesimal Alexander module” as in our (DBN and Zsuzsanna Dancso) paper “Finite Type Invariants of W-Knotted Objects: From Alexander to Kashiwara and Vergne” ( http://www.math.toronto.edu/~drorbn/papers/WKO/ ); continues pensieve://2009-06/.
<p>First working version, needs D conjugation.

<< KnotTheory`

A=Alexander[K = Knot[4,1]][X]

G=GD @@ PD[K] /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]], Ar[l,i,+1], Ar[j,i,-1]]

Drawing Arrow Diagrams

Draw[expr_] := expr /. gd_GD:> Draw[gd];
Draw[gd_GD] := Module[
{n=Length[gd], h, k=0},
Graphics[{
Line[{{0,0}, {2n+1,0}}],
Table[Text[i, {i,-0.3}], {i,2n}],
(List@@gd) /.  {
Ar[i_, j_, s_] :> {
h=Abs[i-j]/2;
BezierCurve[{
{i,0},{i,h}, {(i+j)/2, h}, {j,h}, {j,0}
}, SplineDegree -> 2],
Text[s*(++k), {(i+j)/2, h-0.3}],
Line[{{j-0.2, 0.4}, {j,0}, {j+0.2, 0.4}}]
}
}
}
]
];
Draw[G]

Work in IAM

Conventions for red objects:
  1. Legs start just to the right of the index; ar[0,7] means a red arrow starting to the right of position 0 (that is, to the left of everything) and ending to the right of position 7).
  2. If two (red) indices are the same, the heads are to the right of the tails.
  3. w1[] is the one-legged wheel object.
  3. y[i,j,k] means "red Y with tails at i and j and head at k".

n = 2 Length[G]; range=Range[0,n];
Short[AllRedObjects=Flatten[{
Outer[ar, range, range], Outer[y, range, range, range], w1[]
}]]

The relations associated with a red objects involve all the ways of "pulling one red leg one unit to the left". So d[i] means "a red leg at i minus a red leg at (i-1)":

ar[d[i_], j_] := ar[i,j] - ar[i-1, j] + If[i-1==j, -w1[], 0];
ar[i_,d[j_]] := ar[i,j] - ar[i, j-1]  + If[i==j,  w1[], 0];
y[d[i_], j_, k_] := y[i,j,k] - y[i-1,j,k] +If[i-1==k, w1[], 0];
y[i_,j_,d[k_]] := y[i,j,k] - y[i,j,k-1]+If[i==k, -w1[], 0]+ If[j==k, w1[],0];

Now let's form all the red relations; starting with the anti-symmetry of y:

RedRelations = {};
RR[rel_RuleDelayed] := AppendTo[RedRelations, rel];
SetAttributes[RR, Listable];
RR[y[t1_, t2_, h_] * _. :> y[t1,t2,h] + y[t2,t1,h]];

RR@(({{ , Ar Tail, Ar Head}, {ar
Tail, ar[i_, h_]Ar[i_,j_, s_]*_. :>
ar[d[i], h], ar[j_,h_]Ar[i_, j_, s_]*_. :>
ar[d[j], h]+(X^s-1) y[i,j,h]}, {ar
Head, ar[t_,i_]Ar[i_, j_, s_]*_. :>
ar[t,d[i]]+(X^s-1) y[i,t,j-1], ar[t_,j_]Ar[i_, j_, s_]*_. :>
ar[t,d[j]]-(X^s-1)y[i,t,j-1]}}));

RR@(({{ , Ar Tail, Ar Head}, {y
Tail, y[i_, t_, h_]Ar[i_,j_, s_]*_. :>
y[d[i], t, h], y[j_,t_,h_]Ar[i_, j_, s_]*_. :>
y[d[j],t,h]-(X^s-1) y[i,j,h]}, {y
Head, y[t1_,t2_,i_]Ar[i_,j_,s_]*_. :>
y[t1,t2,d[i]]+(X^s-1) y[t1,t2,j-1], y[t1_,t2_,j_]Ar[i_,j_,s_]*_. :>
y[t1,t2,d[j]]-(X^s-1) y[t1,t2,j-1]}}));

RelationsIn[G_GD, red_] := ReplaceList[
red*(Times @@ Select[G, (Intersection[List@@#, List@@red] =!= {})&]), RedRelations
];
Short[AllRedRelations = Flatten[RelationsIn[G, #]& /@ AllRedObjects]]

rule = Dispatch[Thread[Rule[AllRedObjects, IdentityMatrix[Length[AllRedObjects]]]]];
Short[RedRules=Map[
(
p = First@Part[AllRedObjects, First@Position[#, 1, {1}]];
p -> p-(#.AllRedObjects)
)&,
DeleteCases[mat=Simplify[RowReduce[AllRedRelations /. rule]], {0...}]
]]

Simplify[RedRules[[Table[Random[Integer, {1,Length[RedRules]}], {10}]]]]

lambda=Plus @@ G /. Ar[i_, j_, s_] :> s*ar[i,j]

deltaL=ar[0,0]+w1[]; deltaR=ar[0,0];
{
slL=Plus @@ Cases[G, Ar[i_,j_, s_] /; j<i :> s],
slR=Plus @@ Cases[G, Ar[i_,j_, s_] /; i<j :> s],
SL=slL*deltaL+slR*deltaR
}

Simplify@{lambda-SL /. RedRules, X D[Log[A], X]*w1[]}

There's still a sign issue above!

All G Matrices

Tij[Ar[ti_,hi_,si_], Ar[tj_,hj_,sj_]] := If[
ti<hj<hi || hi<hj<ti,
1,0
];
Tm = Outer[Tij,List@@G, List@@G];
Sm = DiagonalMatrix[List @@ G /. Ar[_,_,s_] :> s];
Dm = DiagonalMatrix[List @@ G /. Ar[t_, h_, _] :> Sign[h-t]];
SDm=Sm.Dm;
Id=IdentityMatrix[n/2];
SD1m = MatrixExp[-Log[X]SDm] - Id;
Bm=Tm.SD1m;
MatrixForm /@ {Tm, Sm, Dm, SDm, SD1m,Bm}

Simplify@{lambda-SL /. RedRules, Tr[Bm.Inverse[Id-Bm].(Id+Tm).SDm]*w1[]}

There's still a sign issue above!

The IAM Matrices

tail[i_] := G[[i,1]];
head[i_] := G[[i,2]];
dir[i_] := Sign[head[i]-tail[i]];
eps = 0.2; (* For all practical purposes, this is "little" *)
lambij[i_,j_] := (
ar[tail[i]+eps*dir[i], head[j]-eps*dir[j]/2] - ar[head[i]-eps*dir[i], head[j]-eps*dir[j]/2]
) /. ar[a_, b_] :> (
ar[Floor[a], Floor[b]] + 
If[Floor[a]==Floor[b] && a>b, w1[], 0]
);
Lambda = Table[lambij[i,j], {i,n/2}, {j,n/2}];
Yij[i_, j_] := y[
head[i]-eps*dir[i], tail[i]+eps*dir[i], head[j]-eps*dir[j]/2
] /. y[a_,b_,c_] :> (
y[Floor[a], Floor[b], Floor[c]] +
If[Floor[b]==Floor[c] && b>c, w1[], 0] +
If[Floor[a]==Floor[c] && a>c, -w1[], 0]
);
Ym = Table[Yij[i,j], {i,n/2}, {j,n/2}];
MatrixForm /@ {Lambda, Ym}

Test 1

test1 = Simplify[{lambda-SL, Tr[Sm.Lambda]} /. RedRules]

{1,-1}.test1

Test 2

MatrixForm /@ (test2=ExpandNumerator[Together[
{Lambda, Dm.Bm.Dm.Ym-Dm.Tm.(SD1m+Id)} /. RedRules /. w1[] -> 1
]])

Simplify[{1,-1}.test2] // MatrixForm

Test 3

MatrixForm /@ (test3=ExpandNumerator[Together[
{Ym, Dm.Bm.Dm.Ym-Dm.Tm.(SD1m+Id)} /. RedRules /. w1[] -> 1
]])

Simplify[{1,-1}.test3] // MatrixForm